home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / macros.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  2KB  |  87 lines
  1. /* ******************************************************************** */
  2. /* macros.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Misc compiled macros                                                 */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, May 1990 
  10.  */
  11.  
  12. #include "defs.h"
  13. #include "structs.h"
  14. #include "error.h"
  15. #include "funcalls.h"
  16.  
  17. #include "global.h"
  18. #include "slots.h"
  19. #include "garbage.h"
  20.  
  21.  
  22. #include "symboot.h"
  23. #include "modules.h"
  24. #include "toplevel.h"
  25. #include "root.h"
  26. #include "allocate.h"
  27. #include "specials.h"
  28.  
  29. #include "modboot.h"
  30.  
  31. extern LispObject sym_append,sym_unquote_splicing,sym_unquote,sym_cons;
  32.  
  33. LispObject unquote_constructor(LispObject *stacktop, LispObject x)
  34. {
  35.   LispObject retval;
  36.  
  37.   /* Atoms... */
  38.  
  39.   if (!is_cons(x)) {
  40.     if (x == nil || !is_symbol(x)) {
  41.       return(x);
  42.     }
  43.     else {
  44.       EUCALLSET_2(x,Fn_cons,x,nil);
  45.       return(EUCALL_2(Fn_cons,sym_quote,x));
  46.     }
  47.   }
  48.  
  49.   if (CAR(x) == sym_unquote) return((CAR(CDR(x))));
  50.  
  51.   if (CAR(x) == sym_unquote_splicing)
  52.     CallError(stacktop,"`: illegal ,@ use",x,NONCONTINUABLE);
  53.  
  54.   STACK_TMP(x);
  55.   if (CAR(CAR(x)) == sym_unquote_splicing) {
  56.     LispObject xx;
  57.     xx = unquote_constructor(stacktop,CDR(x));
  58.     EUCALLSET_2(xx, Fn_cons, xx,nil);
  59.     UNSTACK_TMP(x);
  60.     EUCALLSET_2(xx, Fn_cons, CAR(CDR(CAR(x))), xx);
  61.     return (EUCALL_2(Fn_cons, sym_append, xx));
  62.   }
  63.   
  64.   retval = unquote_constructor(stacktop,CDR(x));
  65.   EUCALLSET_2(retval, Fn_cons, retval,nil);
  66.   UNSTACK_TMP(x);
  67.   STACK_TMP(retval);
  68.   x = unquote_constructor(stacktop,CAR(x));
  69.   UNSTACK_TMP(retval);
  70.   EUCALLSET_2(retval, Fn_cons, x,retval);
  71.   return (EUCALL_2(Fn_cons, sym_cons, retval));
  72.  
  73. }
  74.  
  75. EUFUN_1( Mo_quasiquote, forms)
  76. {
  77.   return(unquote_constructor(stacktop,forms));
  78. }
  79. EUFUN_CLOSE
  80.  
  81. void initialise_macros(LispObject *stacktop)
  82. {
  83.  
  84.   make_module_macro(stacktop,"quasiquote",Mo_quasiquote,1);
  85.  
  86. }
  87.